home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 7 / Apprentice-Release7.iso / Source Code / C / Applications / Tcl-Tk 8.0 / Pre-installed version / tk8.0 / mac / tclets.tcl < prev    next >
Encoding:
Text File  |  1997-08-15  |  5.2 KB  |  216 lines  |  [TEXT/ALFA]
  1. # tclets.tcl --
  2. #
  3. # Drag & Drop Tclets
  4. # by Ray Johnson
  5. #
  6. # A simple way to create Tcl applications.  This applications will copy a droped Tcl file
  7. # into a copy of a stub application (the user can pick).  The file is placed into the
  8. # TEXT resource named "tclshrc" which is automatically executed on startup.
  9. #
  10. # SCCS: @(#) tclets.tcl 1.2 97/08/15 09:25:56
  11. #
  12. # Copyright (c) 1997 Sun Microsystems, Inc.
  13. #
  14. # See the file "license.terms" for information on usage and redistribution
  15. # of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  16. #
  17.  
  18. # tkOpenDocument --
  19. #
  20. #    This procedure is a called whenever Wish recieves an "Open" event.  The
  21. #    procedure must be named tkOpenDocument for this to work.  Passed in files
  22. #    are assumed to be Tcl files that the user wants to be made into Tclets.
  23. #    (Only the first one is used.)  The procedure then creates a copy of the
  24. #    stub app and places the Tcl file in the new application's resource fork.
  25. #
  26. # Parameters:
  27. #    args        List of files
  28. #
  29. # Results:
  30. #     One success a new Tclet is created.
  31.  
  32. proc tkOpenDocument {args} {
  33.     global droped_to_start
  34.     
  35.     # We only deal with the one file droped on the App
  36.     set tclFile [lindex $args 0]
  37.     set stub [GetStub]
  38.     
  39.     # Give a helper screen to guide user
  40.     toplevel .helper -menu .bar
  41.     unsupported1 style .helper dBoxProc
  42.     message .helper.m -aspect 300 -text \
  43.     "Select the name & location of your target Tcl application."
  44.     pack .helper.m
  45.     wm geometry .helper +20+40
  46.     update idletasks
  47.     
  48.     # Get the target file from the end user
  49.     set target [tk_getSaveFile]
  50.     destroy .helper
  51.     if {$target == ""} return
  52.     
  53.     # Copy stub, copy the droped file into the stubs text resource
  54.     file copy $stub $target
  55.     set id [open $tclFile r]
  56.     set rid [resource open $target w]
  57.     resource write -name tclshrc -file $rid TEXT [read $id]
  58.     resource close $rid
  59.     close $id
  60.     
  61.     # This is a hint to the start-up code - always set to true
  62.     set droped_to_start true
  63. }
  64.  
  65. # GetStub --
  66. #
  67. #    Get the location of our stub application.  The value may be cached,
  68. #    in the preferences file, or we may need to ask the user.
  69. #
  70. # Parameters:
  71. #    None.
  72. #
  73. # Results:
  74. #     A path to the stub application.
  75.  
  76. proc GetStub {} {
  77.     global env stub_location
  78.     
  79.     if {[info exists stub_location]} {
  80.     return $stub_location
  81.     }
  82.     
  83.     set file $env(PREF_FOLDER)
  84.     append file "D&D Tclet Preferences"
  85.     
  86.     
  87.     if {[file exists $file]} {
  88.     uplevel #0 [list source $file]
  89.     if {[info exists stub_location] && [file exists $stub_location]} {
  90.         return $stub_location
  91.     }
  92.     }
  93.  
  94.     SelectStub
  95.  
  96.     if {[info exists stub_location]} {
  97.     return $stub_location
  98.     } else {
  99.     exit
  100.     }
  101. }
  102.  
  103. # SelectStub --
  104. #
  105. #    This procedure uses tk_getOpenFile to allow the user to select
  106. #    the copy of "Wish" that is used as the basis for Tclets.  The
  107. #    result is stored in a preferences file.
  108. #
  109. # Parameters:
  110. #    None.
  111. #
  112. # Results:
  113. #     None.  The prefernce file is updated.
  114.  
  115. proc SelectStub {} {
  116.     global env stub_location
  117.  
  118.     # Give a helper screen to guide user
  119.     toplevel .helper -menu .bar
  120.     unsupported1 style .helper dBoxProc
  121.     message .helper.m -aspect 300 -text \
  122.         "Select \"Wish\" stub to clone.  A copy of this application will be made to create your Tclet." \
  123.     
  124.     pack .helper.m
  125.     wm geometry .helper +20+40
  126.     update idletasks
  127.  
  128.     set new_location [tk_getOpenFile]
  129.     destroy .helper
  130.     if {$new_location != ""} {
  131.     set stub_location $new_location
  132.     set file [file join $env(PREF_FOLDER) "D&D Tclet Preferences"]
  133.     
  134.     set id [open $file w]
  135.     puts $id [list set stub_location $stub_location]
  136.     close $id
  137.     }
  138. }
  139.  
  140. # CreateMenus --
  141. #
  142. #    Create the menubar for this application.
  143. #
  144. # Parameters:
  145. #    None.
  146. #
  147. # Results:
  148. #     None.
  149.  
  150. proc CreateMenus {} {
  151.     menu .bar
  152.     .bar add cascade -menu .bar.file -label File
  153.     .bar add cascade -menu .bar.apple
  154.     . configure -menu .bar
  155.     
  156.     menu .bar.apple -tearoff 0
  157.     .bar.apple add command -label "About Drag & Drop Tclets..." -command {ShowAbout}
  158.  
  159.     menu .bar.file -tearoff 0
  160.     .bar.file add command -label "Show Console..." -command {console show}
  161.     .bar.file add command -label "Select Wish Stub..." -command {SelectStub}
  162.     .bar.file add separator
  163.     .bar.file add command -label "Quit" -accel Command-Q -command exit
  164. }
  165.  
  166. # ShowAbout --
  167. #
  168. #    Show the about box for Drag & Drop Tclets.
  169. #
  170. # Parameters:
  171. #    None.
  172. #
  173. # Results:
  174. #     None.
  175.  
  176. proc ShowAbout {} {
  177.     tk_messageBox -icon info -type ok -message \
  178. "Drag & Drop Tclets
  179. by Ray Johnson\n\n\
  180. Copyright (c) 1997 Sun Microsystems, Inc."
  181. }
  182.  
  183. # Start --
  184. #
  185. #    This procedure provides the main start-up code for the application.
  186. #    It should be run first thing on start up.  It will create the UI
  187. #    and set up the rest of the state of the application.
  188. #
  189. # Parameters:
  190. #    None.
  191. #
  192. # Results:
  193. #     None.
  194.  
  195. proc Start {} {
  196.     global droped_to_start
  197.  
  198.     # Hide . & console - see if we ran as a droped item
  199.     wm geometry . 1x1-25000-25000
  200.     console hide
  201.  
  202.     # Run update - if we get any drop events we know that we were
  203.     # started by a drag & drop - if so, we quit automatically when done
  204.     set droped_to_start false
  205.     update
  206.     if {$droped_to_start == "true"} {
  207.     exit
  208.     }
  209.     
  210.     # We were not started by a drag & drop - create the UI
  211.     CreateMenus
  212. }
  213.  
  214. # Now that everything is defined, lets start the app!
  215. Start
  216.